(library (pass-mark-calls)
(export pass-mark-calls)
(import (chezscheme) (utils) (match))

(define (pass-mark-calls prg)
  (let ((definitions (cdr (assoc 'definitions prg)))
        (code (cdr (assoc 'code prg))))
    `((definitions . ,definitions)
      (code . ,(map* pass-mark-calls-code code)))))

(define (pass-mark-calls-code code)
  (let ((label (car code))
        (env (cadr code))
        (binds (caddr code))
	(num-temps (cadddr code))
        (exp (caddddr code)))
    `(,label ,env ,binds ,num-temps ,(pass-mark-calls-let exp #t '(ret) label (box 0)))))

(define (pass-mark-calls-let exp tail-position into label i)
  `(begin . ,(match exp
               (`(let* ,binds ,body)
                (let ((binds^ (map* (lambda (bind) (pass-mark-calls-bind bind label i)) binds)))
                  `(let* ,binds ,(pass-mark-calls-exp body tail-position into label i))))
	       (else (pass-mark-calls-exp exp tail-position into label i)))))
;; TODO fix it up to make a let* instead 

(define (pass-mark-calls-bind bind label i)
  (match bind
    (`(,var ,exp) (pass-mark-calls-exp exp #f var label i))
    (else (error 'pass-mark-calls-bind "not a valid bind expression in let*" bind))))

;; if tail-position is #t then we compile the expression to place the data into
;; the return register or if it was a function call, do a tail call
;; otherwise 'into' must be a valid place and we store the data into there
;; or if it was a function call, perform the call and save the return register
;; into it.
;;
(define (pass-mark-calls-exp exp tail-position into label i)
  (match exp
    (`(atomic ,x) (pass-mark-calls-return-into exp tail-position into))
    (`(var ,type ,x) (pass-mark-calls-return-into exp tail-position into))
    (`(closure ,x ,y ,z) (pass-mark-calls-return-into exp tail-position into))
    (`(quote ,x) (pass-mark-calls-return-into exp tail-position into))
    (`(builtin ,nm . ,args) (pass-mark-calls-return-into exp tail-position into))
    (`(app . ,vars)
     (if tail-position
         (list `(tail-call . ,vars))
         (let* ((ctr (unbox i))
                (label (append label (list ctr))))
           (set-box! i (+ ctr 1))
           (list `(call ,label . ,vars)
		 `(label ,label)
		 `(set! ,into (ret))))))
    (`(if ,t ,c ,a)
      (list `(if ,t
                 ,(pass-mark-calls-let c #t into label i)
                 ,(pass-mark-calls-let a #t into label i))))
    (else (error 'pass-mark-calls-exp "not a valid expression inside the body of a let*" exp))))

(define (pass-mark-calls-return-into exp tail-position into)
  (if tail-position
      (list `(return ,exp))
      (begin
        (when (and (equal? into '(ret)) (equal? exp '(ret)))
          (error 'pass-mark-calls-return-into "moving ret into ret"))
        (list `(set! ,into ,exp)))))

)
